PSJRXLAB ;ALB/RTW -  drug+lab result print ; 03/25/2016 10:06
 ;;5.0;INPATIENT PHARMACY;**327**;DEC 1997
 ;RTW copied from routine PSORXLAB and modified for the Inpatient NCC Clozapine inpatient pharmacy project
 ;FSIG and FSIG2(formerly EN2), are brought in from PSOUTLA and PSOUTLA1 
 ;a routine which loop thru the last fill order of ^PS(55 and gets
 ;patients with a specific drug. then gets the lrdfn from the 
 ;patient file and loops thru the patients lab data to find
 ;results within the date range you specify for the lab test
 ;used to minitor the drug. it then prints the patient's name
 ;ssn, last fill date, and the lab test results if any.
 ;this is intended as a qa minitor and should not be run for
 ;more than a 30 day fill date interval, or 1 year lab test interval.
 ;External ref. to ^LAB(60, is supp. by DBIA# 333
 ;External ref. to ^LR(LRDFN,"CH", is supp. by DBIA# 844
 ;External ref. to ^PSDRUG( is supp. by DBIA# 221
 ;External ref. to ^VA(200, is supp. by DBIA# 10060
PSJSITE K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^")
 N PSCNT
 S PSCNT=0
 I $G(DA) D
 .S DIC=4,DIQ(0)="I",DR=".01;99" D EN^DIQ1
 .S SITE=$G(^UTILITY("DIQ1",$J,4,DA,.01,"I"))_" "_$G(^UTILITY("DIQ1",$J,4,DA,99,"I"))
 .K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
 S Y=DT X ^DD("DD") S SITE=$G(SITE)_" "_Y
BDATE S %DT="EXTA",%DT("A")="Beginning fill date: " D ^%DT G CLEAN:Y<0 S PSJBD=Y X ^DD("DD") S PSJBDR=Y
EDATE S %DT("A")="Ending last fill date: " D ^%DT G CLEAN:Y<0 S PSJED=Y X ^DD("DD") S PSJEDR=Y
LDATE S %DT("A")="Earliest date for lab results: " D ^%DT G CLEAN:Y<0 S LDATE=Y X ^DD("DD") S LDATER=Y
DRUG R !,"Enter the key word in the Drug Generic name: ",PSJDRUG:DTIME G CLEAN:'$T I "^"[PSJDRUG G CLEAN
 I $O(^PSDRUG("B",$E(PSJDRUG,1,$L(PSJDRUG)-1)))'[PSJDRUG W !,"No corresponding entry, try again or type return to exit" G DRUG
LABT S DIC="^LAB(60,",DIC(0)="QEAM" D ^DIC K DIC G:Y<0 CLEAN S PSJLBT=$P(Y,"^"),PSJLABTN=$P(Y,"^",2) G:PSJLBT="" CLEAN I $G(^LAB(60,PSJLBT,.2))']"" W !!,$C(7),"Data Name missing !!",! K Y,PSJLBT G LABT
 S PSJLABT=^LAB(60,PSJLBT,.2)
 W !,"Enter the specimen used in the lab for this test, serum,plasma,blood etc."
PSJSP S DIC="^LAB(61,",DIC(0)="QEAM" D ^DIC G:Y<0 CLEAN S PSJSP=$P(Y,"^") G:PSJSP="" CLEAN ;;I $P($G(^LAB(60,PSJLBT,1,PSJSP,0)),"^",7)']"" W !!,$C(7),"Specimen data missing !!",! ;K Y,PSJSP G PSJSP
PSJUNIT S PSJUNIT=$S($G(PSJSP)]"":$P($G(^LAB(60,PSJLBT,1,PSJSP,0)),"^",7),1:"")
PSJANS R !,"Do you want Order info? N// ",PSJANS:DTIME G CLEAN:'$T S:PSJANS="" PSJANS="N" G:PSJANS="^" CLEAN2 I "YN"'[PSJANS W !,"ANSWER YES OR NO" G PSJANS
DEVICE K IOP S %ZIS="MQ" D ^%ZIS G:POP CLEAN2
 I $D(IO("Q")) K IO("Q") S ZTSAVE("*")="",ZTRTN="DQ^PSJRXLAB",ZTDESC="LAB LIST" D ^%ZTLOAD K ZTSK G CLEAN
DQ S PSJLABQ=0 S PSJBD=PSJBD-1,PAGE=0 U IO W @IOF D HDR
LOOP1 N PSJ F PSJ=0:0 S PSJBD=$O(^OR(100,"AD",PSJBD)) Q:PSJBD=""!($G(PSJLABQ))  Q:PSJBD>PSJED  S PSJORDN=0 D LOOP2
 G CLEAN
LOOP2 N PSJ2 F PSJ2=0:0 S PSJORDN=$O(^OR(100,"AD",PSJBD,PSJORDN)) Q:PSJORDN=""!($G(PSJLABQ))  D:$G(^OR(100,PSJORDN,0))]"" CHECK1
 Q
CHECK1 ;
 N PSJNUM
 S PSCNT=PSCNT+1
 S ^TMP("ORDERNUM",PSCNT)=PSJORDN
 S PSJNUM=0 F  S PSJNUM=$O(^OR(100,PSJORDN,4.5,PSJNUM)) Q:'PSJNUM  D
 . I $P(^OR(100,PSJORDN,4.5,PSJNUM,0),"^",4)["DRUG" D
 . . S PSJDGN=$P($G(^OR(100,PSJORDN,4.5,PSJNUM,1)),"^",1),PSJDRUGN=$P($G(^PSDRUG(PSJDGN,0)),"^")
 Q:'$D(PSJDGN)
 I PSJDRUGN'[PSJDRUG Q
 Q:'$P($G(^OR(100,PSJORDN,0)),"^",4)  S PSJPROV=$P(^OR(100,PSJORDN,0),"^",4),PSJPROVN=$P(^VA(200,PSJPROV,0),"^"),PSJPROT=$P(^VA(200,PSJPROV,0),"^",5)
 S PSJTYPE="NONE" I PSJPROT S PSJTYPE=$P("FULL TIME^PART TIME^C & A^FEE^STAFF","^",PSJPROT)
CHECK2 Q:'$P($G(^OR(100,PSJORDN,0)),"^",2)
 S (PSJPT)=+$P(^OR(100,PSJORDN,0),"^",2) W ! D PID^VADPT,PRINT2
 I '$D(^DPT(PSJPT,"LR")) W ?55,"No lab data exists",?81,$E(PSJPROVN,1,20),?106,PSJTYPE,! D:PSJANS["Y" PSJORDNI Q
 S LRDFN=$P(^DPT(PSJPT,"LR"),"^"),PSJLBENT=0,PSJINDIC=0
LOOP3 F J2=0:0 S PSJLBENT=$O(^LR(LRDFN,"CH",PSJLBENT)) Q:PSJLBENT=""!($G(PSJLABQ))  S PSJLDATE=$P(^LR(LRDFN,"CH",PSJLBENT,0),"^") Q:PSJLDATE<LDATE  D CHECK3
 I PSJINDIC=0 W ?55,"NO LAB DATA IN RANGE",?81,$E(PSJPROVN,1,20),?106,PSJTYPE,!
 D:PSJANS["Y" PSJORDNI
 Q
CHECK3 I $D(^LR(LRDFN,"CH",PSJLBENT,PSJLABT)) D RESULT
 Q
RESULT Q:$P(^LR(LRDFN,"CH",PSJLBENT,0),"^",5)'=PSJSP  Q:'$P(^(0),"^",3)
 S Y=PSJLDATE X ^DD("DD") W ?55,$E(Y,1,11),?70,$P(^LR(LRDFN,"CH",PSJLBENT,PSJLABT),"^")_" "_PSJUNIT,?81,$E(PSJPROVN,1,20),?106,PSJTYPE W !
 S PSJINDIC=1 Q
 Q
PRINT2 I $Y>(IOSL-6) D  Q:$G(PSJLABQ)  W @IOF,SITE,! D HDR2
 .I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJLABQ=1
 W ?1,$E($P(^DPT(PSJPT,0),"^"),1,20),?25,VA("PID") S Y=PSJBD X ^DD("DD") W ?43,Y Q
HDR W SITE,!!,"Patients receiving "_PSJDRUG_" with fills between "_PSJBDR_" and "_PSJEDR,!," with date of collection and results for lab test "_PSJLABTN_" after ",LDATER,!
HDR2 S PAGE=PAGE+1 W !,"Name",?25,"ID#",?43,"Fill Date",?55,"Lab Date",?71,"Results",?81,"Order Provider",?106,"Type",?116,"Page "_PAGE,!
 F J=1:1:IOM-1 W "_"
 W ! Q
PSJORDNI N DTOUT,DUOUT Q:$G(PSJLABQ)  W "Order #: "_$P(^OR(100,PSJORDN,0),"^")_"   Drug: "_$P(^PSDRUG(PSJDGN,0),"^")
 K FSIG,BSIG I $P($G(^OR(100,PSJORDN,4.5,5,1)),"^") D FSIG("O",PSJORDN,72) F PSREV=1:1 Q:'$D(FSIG(PSREV))  S BSIG(PSREV)=FSIG(PSREV)
 K FSIG,PSREV I '$P($G(^OR(100,PSJORDN,4.5,5,1)),"^") D FSIG2(PSJORDN,72)
 W !?1,"Sig: ",$G(BSIG(1))
 I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?6,$G(BSIG(PSREV))
 I $Y>(IOSL-6) D  Q:$G(PSJLABQ)  W @IOF,SITE,! D HDR2
 .I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJLABQ=1
 W ! Q
CLEAN W @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
CLEAN2 K PSJINDIC,PSJPT,PSJLDATE,PAGE,PSJBD,PSJBDR,PSJLBENT,PSJLABT,PSJDGN,PSJDRUGN,PSJDRUG,J,J1,J2,PSJORDN,PSJPROV,PSJPROVN,LDATE,LDATER,PSJED,PSJEDR,PSJPROT,PSJTYPE,PSJLABTN,PSJLBT,PSJSP,PSJUNIT,PSJANS,DIC,LRDFN,POP,SITE,Y,%DT,PSJLABQ
 K ZTDESC,ZTRTN,ZTSAVE,%ZIS,^TMP("ORDERNUM") Q
FSIG(PSJFILE,PSJINTR,PSJLENTH) ;Format front door sig
 ;PSJFILE is 'P' if in Pending File, 'R' if in Prescription File
 ;PSJINTR is internal number for either file
 ;PSJLENTH is length of each line of the Sig
 ;returned in the FSIG array
 K FSIG I $G(PSJFILE)=""!('$G(PSJINTR))!('$G(PSJLENTH)) G FQUIT
 I PSJFILE'="P",PSJFILE'="O" G FQUIT
 I PSJFILE="P",'$D(^PS(52.41,+PSJINTR,0)) G FQUIT
 I PSJFILE="O",'$D(^OR(100,+PSJINTR,0)) G FQUIT
 I PSJFILE="O",'$P($G(^OR(100,+PSJINTR,"SIG")),"^",2) G FQUIT
 N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II
 I PSJFILE="P" F NNN=0:0 S NNN=$O(^PS(52.41,PSJINTR,"SIG",NNN)) Q:'NNN  S:$G(^(NNN,0))'="" HSIG(NNN)=^(0)
 I PSJFILE="P" G:'$O(HSIG(0)) FQUIT G FSTART
 S FFF=1 F NNN=0:0 S NNN=$O(^OR(100,PSJINTR,"SIG1",NNN)) Q:'NNN  I $G(^(NNN,0))'="" S HSIG(FFF)=^(0) S FFF=FFF+1
 G:'$O(HSIG(0)) FQUIT
FSTART S (FVAR,FVAR1)="",II=1
 F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF  S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D  I $L(FVAR)>PSJLENTH S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
 .S FVAR1=$P(HSIG(FFF)," ",(CNT))
 .S FLIM=FVAR
 .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
 I $G(FVAR)'="" S FSIG(II)=FVAR
 I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
FQUIT Q
FSIG2(PSJBINTR,PSJBLGTH) ;
 K BSIG
 N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM
 S BBSIG=$P($G(^OR(100,PSJBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
 S (BVAR,BVAR1)="",III=1
 S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D  I $L(BVAR)>PSJBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
 .S BVAR1=$P(BBSIG," ",(CNT))
 .S BLIM=BVAR
 .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
 I $G(BVAR)'="" S BSIG(III)=BVAR
 I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
 Q
 ;
